home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / pc / files / ant_nec / nec_in_c.tz / nec_in_c / NEC2 / lread.c < prev    next >
C/C++ Source or Header  |  1992-02-13  |  9KB  |  546 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "lio.h"
  5. #include "ctype.h"
  6. #include "fp.h"
  7.  
  8. extern char *fmtbuf;
  9. extern char *malloc(), *realloc();
  10. int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
  11. int l_eof;
  12.  
  13. #define isblnk(x) (ltab[x+1]&B)
  14. #define issep(x) (ltab[x+1]&SX)
  15. #define isapos(x) (ltab[x+1]&AX)
  16. #define isexp(x) (ltab[x+1]&EX)
  17. #define issign(x) (ltab[x+1]&SG)
  18. #define iswhit(x) (ltab[x+1]&WH)
  19. #define SX 1
  20. #define B 2
  21. #define AX 4
  22. #define EX 8
  23. #define SG 16
  24. #define WH 32
  25. char ltab[128+1] = {    /* offset one for EOF */
  26.     0,
  27.     0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  28.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  29.     SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  30.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  31.     0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  32.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  33.     AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  34.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  35. };
  36.  
  37. t_getc()
  38. {    int ch;
  39.     if(curunit->uend) return(EOF);
  40.     if((ch=getc(cf))!=EOF) return(ch);
  41.     if(feof(cf))
  42.         l_eof = curunit->uend = 1;
  43.     return(EOF);
  44. }
  45. integer e_rsle()
  46. {
  47.     int ch;
  48.     if(curunit->uend) return(0);
  49.     while((ch=t_getc())!='\n' && ch!=EOF);
  50.     return(0);
  51. }
  52.  
  53. flag lquit;
  54. int lcount,ltype,nml_read;
  55. char *lchar;
  56. double lx,ly;
  57. #define ERR(x) if(n=(x)) return(n)
  58. #define GETC(x) (x=(*l_getc)())
  59. #define Ungetc(x,y) (*l_ungetc)(x,y)
  60.  
  61. l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  62. {
  63. #define Ptr ((flex *)ptr)
  64.     int i,n,ch;
  65.     doublereal *yy;
  66.     real *xx;
  67.     for(i=0;i<*number;i++)
  68.     {
  69.         if(lquit) return(0);
  70.         if(l_eof)
  71.             err(elist->ciend, EOF, "list in")
  72.         if(lcount == 0) {
  73.             ltype = 0;
  74.             for(;;)  {
  75.                 GETC(ch);
  76.                 switch(ch) {
  77.                 case EOF:
  78.                     goto loopend;
  79.                 case ' ':
  80.                 case '\t':
  81.                 case '\n':
  82.                     continue;
  83.                 case '/':
  84.                     lquit = 1;
  85.                     goto loopend;
  86.                 case ',':
  87.                     lcount = 1;
  88.                     goto loopend;
  89.                 default:
  90.                     (void) Ungetc(ch, cf);
  91.                     goto rddata;
  92.                 }
  93.             }
  94.         }
  95.     rddata:
  96.         switch((int)type)
  97.         {
  98.         case TYSHORT:
  99.         case TYLONG:
  100.         case TYREAL:
  101.         case TYDREAL:
  102.             ERR(l_R(0));
  103.             break;
  104.         case TYCOMPLEX:
  105.         case TYDCOMPLEX:
  106.             ERR(l_C());
  107.             break;
  108.         case TYLOGICAL:
  109.             ERR(l_L());
  110.             break;
  111.         case TYCHAR:
  112.             ERR(l_CHAR());
  113.             break;
  114.         }
  115.     while (GETC(ch) == ' ' || ch == '\t');
  116.     if (ch != ',' || lcount > 1)
  117.         Ungetc(ch,cf);
  118.     loopend:
  119.         if(lquit) return(0);
  120.         if(cf) {
  121.             if (feof(cf))
  122.                 err(elist->ciend,(EOF),"list in")
  123.             else if(ferror(cf)) {
  124.                 clearerr(cf);
  125.                 err(elist->cierr,errno,"list in")
  126.                 }
  127.             }
  128.         if(ltype==0) goto bump;
  129.         switch((int)type)
  130.         {
  131.         case TYSHORT:
  132.             Ptr->flshort=lx;
  133.             break;
  134.         case TYLOGICAL:
  135.         case TYLONG:
  136.             Ptr->flint=lx;
  137.             break;
  138.         case TYREAL:
  139.             Ptr->flreal=lx;
  140.             break;
  141.         case TYDREAL:
  142.             Ptr->fldouble=lx;
  143.             break;
  144.         case TYCOMPLEX:
  145.             xx=(real *)ptr;
  146.             *xx++ = lx;
  147.             *xx = ly;
  148.             break;
  149.         case TYDCOMPLEX:
  150.             yy=(doublereal *)ptr;
  151.             *yy++ = lx;
  152.             *yy = ly;
  153.             break;
  154.         case TYCHAR:
  155.             b_char(lchar,ptr,len);
  156.             break;
  157.         }
  158.     bump:
  159.         if(lcount>0) lcount--;
  160.         ptr += len;
  161.         if (nml_read)
  162.             nml_read++;
  163.     }
  164.     return(0);
  165. #undef Ptr
  166. }
  167. l_R(poststar)
  168.  int poststar;
  169. {
  170.     char s[FMAX+EXPMAXDIGS+4];
  171.     register int ch;
  172.     register char *sp, *spe, *sp1;
  173.     long e, exp;
  174.     double atof();
  175.     int havenum, havestar, se;
  176.  
  177.     if (!poststar) {
  178.         if (lcount > 0)
  179.             return(0);
  180.         lcount = 1;
  181.         }
  182.     ltype = 0;
  183.     exp = 0;
  184.     havestar = 0;
  185. retry:
  186.     sp1 = sp = s;
  187.     spe = sp + FMAX;
  188.     havenum = 0;
  189.  
  190.     switch(GETC(ch)) {
  191.         case '-': *sp++ = ch; sp1++; spe++;
  192.         case '+':
  193.             GETC(ch);
  194.         }
  195.     while(ch == '0') {
  196.         ++havenum;
  197.         GETC(ch);
  198.         }
  199.     while(isdigit(ch)) {
  200.         if (sp < spe) *sp++ = ch;
  201.         else ++exp;
  202.         GETC(ch);
  203.         }
  204.     if (ch == '*' && !poststar) {
  205.         if (sp == sp1 || exp || *s == '-') {
  206.             err(elist->cierr,112,"bad repetition count")
  207.             }
  208.         poststar = havestar = 1;
  209.         *sp = 0;
  210.         lcount = atoi(s);
  211.         goto retry;
  212.         }
  213.     if (ch == '.') {
  214.         GETC(ch);
  215.         if (sp == sp1)
  216.             while(ch == '0') {
  217.                 ++havenum;
  218.                 --exp;
  219.                 GETC(ch);
  220.                 }
  221.         while(isdigit(ch)) {
  222.             if (sp < spe)
  223.                 { *sp++ = ch; --exp; }
  224.             GETC(ch);
  225.             }
  226.         }
  227.     se = 0;
  228.     if (issign(ch))
  229.         goto signonly;
  230.     if (isexp(ch)) {
  231.         GETC(ch);
  232.         if (issign(ch)) {
  233. signonly:
  234.             if (ch == '-') se = 1;
  235.             GETC(ch);
  236.             }
  237.         if (!isdigit(ch)) {
  238. bad:
  239.             err(elist->cierr,112,"exponent field")
  240.             }
  241.  
  242.         e = ch - '0';
  243.         while(isdigit(GETC(ch))) {
  244.             e = 10*e + ch - '0';
  245.             if (e > EXPMAX)
  246.                 goto bad;
  247.             }
  248.         if (se)
  249.             exp -= e;
  250.         else
  251.             exp += e;
  252.         }
  253.     (void) Ungetc(ch, cf);
  254.     if (sp > sp1) {
  255.         ++havenum;
  256.         while(*--sp == '0')
  257.             ++exp;
  258.         if (exp)
  259.             sprintf(sp+1, "e%ld", exp);
  260.         else
  261.             sp[1] = 0;
  262.         lx = atof(s);
  263.         }
  264.     else
  265.         lx = 0.;
  266.     if (havenum)
  267.         ltype = TYLONG;
  268.     else
  269.         switch(ch) {
  270.             case ',':
  271.             case '/':
  272.                 break;
  273.             default:
  274.                 if (havestar && ( ch == ' '
  275.                         ||ch == '\t'
  276.                         ||ch == '\n'))
  277.                     break;
  278.                 if (nml_read > 1) {
  279.                     lquit = 2;
  280.                     return 0;
  281.                     }
  282.                 err(elist->cierr,112,"invalid number")
  283.             }
  284.     return 0;
  285.     }
  286.  
  287.  static int
  288. rd_count(ch)
  289.  register int ch;
  290. {
  291.     if (ch < '0' || ch > '9')
  292.         return 1;
  293.     lcount = ch - '0';
  294.     while(GETC(ch) >= '0' && ch <= '9')
  295.         lcount = 10*lcount + ch - '0';
  296.     Ungetc(ch,cf);
  297.     return lcount <= 0;
  298.     }
  299.  
  300. l_C()
  301. {    int ch, nml_save;
  302.     double lz;
  303.     if(lcount>0) return(0);
  304.     ltype=0;
  305.     GETC(ch);
  306.     if(ch!='(')
  307.     {
  308.         if (nml_read > 1 && (ch < '0' || ch > '9')) {
  309.             Ungetc(ch,cf);
  310.             lquit = 2;
  311.             return 0;
  312.             }
  313.         if (rd_count(ch))
  314.             if(!cf || !feof(cf))
  315.                 err(elist->cierr,112,"complex format")
  316.             else
  317.                 err(elist->cierr,(EOF),"lread");
  318.         if(GETC(ch)!='*')
  319.         {
  320.             if(!cf || !feof(cf))
  321.                 err(elist->cierr,112,"no star")
  322.             else
  323.                 err(elist->cierr,(EOF),"lread");
  324.         }
  325.         if(GETC(ch)!='(')
  326.         {    Ungetc(ch,cf);
  327.             return(0);
  328.         }
  329.     }
  330.     else
  331.         lcount = 1;
  332.     while(iswhit(GETC(ch)));
  333.     Ungetc(ch,cf);
  334.     nml_save = nml_read;
  335.     nml_read = 0;
  336.     if (ch = l_R(1))
  337.         return ch;
  338.     if (!ltype)
  339.         err(elist->cierr,112,"no real part");
  340.     lz = lx;
  341.     while(iswhit(GETC(ch)));
  342.     if(ch!=',')
  343.     {    (void) Ungetc(ch,cf);
  344.         err(elist->cierr,112,"no comma");
  345.     }
  346.     while(iswhit(GETC(ch)));
  347.     (void) Ungetc(ch,cf);
  348.     if (ch = l_R(1))
  349.         return ch;
  350.     if (!ltype)
  351.         err(elist->cierr,112,"no imaginary part");
  352.     while(iswhit(GETC(ch)));
  353.     if(ch!=')') err(elist->cierr,112,"no )");
  354.     ly = lx;
  355.     lx = lz;
  356.     nml_read = nml_save;
  357.     return(0);
  358. }
  359. l_L()
  360. {
  361.     int ch;
  362.     if(lcount>0) return(0);
  363.     ltype=0;
  364.     GETC(ch);
  365.     if(isdigit(ch))
  366.     {
  367.         rd_count(ch);
  368.         if(GETC(ch)!='*')
  369.             if(!cf || !feof(cf))
  370.                 err(elist->cierr,112,"no star")
  371.             else
  372.                 err(elist->cierr,(EOF),"lread");
  373.         GETC(ch);
  374.     }
  375.     if(ch == '.') GETC(ch);
  376.     switch(ch)
  377.     {
  378.     case 't':
  379.     case 'T':
  380.         lx=1;
  381.         break;
  382.     case 'f':
  383.     case 'F':
  384.         lx=0;
  385.         break;
  386.     default:
  387.         if(isblnk(ch) || issep(ch) || ch==EOF)
  388.         {    (void) Ungetc(ch,cf);
  389.             return(0);
  390.         }
  391.         else    err(elist->cierr,112,"logical");
  392.     }
  393.     ltype=TYLONG;
  394.     lcount = 1;
  395.     while(!issep(GETC(ch)) && ch!=EOF);
  396.     (void) Ungetc(ch, cf);
  397.     return(0);
  398. }
  399. #define BUFSIZE    128
  400. l_CHAR()
  401. {    int ch,size,i;
  402.     char quote,*p;
  403.     if(lcount>0) return(0);
  404.     ltype=0;
  405.     if(lchar!=NULL) free(lchar);
  406.     size=BUFSIZE;
  407.     p=lchar=malloc((unsigned int)size);
  408.     if(lchar==NULL) err(elist->cierr,113,"no space");
  409.  
  410.     GETC(ch);
  411.     if(isdigit(ch)) {
  412.         /* allow Fortran 8x-style unquoted string...    */
  413.         /* either find a repetition count or the string    */
  414.         lcount = ch - '0';
  415.         *p++ = ch;
  416.         for(i = 1;;) {
  417.             switch(GETC(ch)) {
  418.                 case '*':
  419.                     if (lcount == 0) {
  420.                         lcount = 1;
  421.                         goto noquote;
  422.                         }
  423.                     p = lchar;
  424.                     goto have_lcount;
  425.                 case ',':
  426.                 case ' ':
  427.                 case '\t':
  428.                 case '\n':
  429.                 case '/':
  430.                     Ungetc(ch,cf);
  431.                     /* no break */
  432.                 case EOF:
  433.                     lcount = 1;
  434.                     ltype = TYCHAR;
  435.                     return *p = 0;
  436.                 }
  437.             if (!isdigit(ch)) {
  438.                 lcount = 1;
  439.                 goto noquote;
  440.                 }
  441.             *p++ = ch;
  442.             lcount = 10*lcount + ch - '0';
  443.             if (++i == size) {
  444.                 lchar = realloc(lchar,
  445.                     (unsigned int)(size += BUFSIZE));
  446.                 p = lchar + i;
  447.                 }
  448.             }
  449.         }
  450.     else    (void) Ungetc(ch,cf);
  451.  have_lcount:
  452.     if(GETC(ch)=='\'' || ch=='"') quote=ch;
  453.     else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
  454.     {    (void) Ungetc(ch,cf);
  455.         return(0);
  456.     }
  457.     else {
  458.         /* Fortran 8x-style unquoted string */
  459.         *p++ = ch;
  460.         for(i = 1;;) {
  461.             switch(GETC(ch)) {
  462.                 case ',':
  463.                 case ' ':
  464.                 case '\t':
  465.                 case '\n':
  466.                 case '/':
  467.                     Ungetc(ch,cf);
  468.                     /* no break */
  469.                 case EOF:
  470.                     ltype = TYCHAR;
  471.                     return *p = 0;
  472.                 }
  473.  noquote:
  474.             *p++ = ch;
  475.             if (++i == size) {
  476.                 lchar = realloc(lchar,
  477.                     (unsigned int)(size += BUFSIZE));
  478.                 p = lchar + i;
  479.                 }
  480.             }
  481.         }
  482.     ltype=TYCHAR;
  483.     for(i=0;;)
  484.     {    while(GETC(ch)!=quote && ch!='\n'
  485.             && ch!=EOF && ++i<size) *p++ = ch;
  486.         if(i==size)
  487.         {
  488.         newone:
  489.             lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
  490.             p=lchar+i-1;
  491.             *p++ = ch;
  492.         }
  493.         else if(ch==EOF) return(EOF);
  494.         else if(ch=='\n')
  495.         {    if(*(p-1) != '\\') continue;
  496.             i--;
  497.             p--;
  498.             if(++i<size) *p++ = ch;
  499.             else goto newone;
  500.         }
  501.         else if(GETC(ch)==quote)
  502.         {    if(++i<size) *p++ = ch;
  503.             else goto newone;
  504.         }
  505.         else
  506.         {    (void) Ungetc(ch,cf);
  507.             *p = 0;
  508.             return(0);
  509.         }
  510.     }
  511. }
  512. integer s_rsle(a) cilist *a;
  513. {
  514.     int n;
  515.     extern int ungetc();
  516.  
  517.     if(!init) f_init();
  518.     if(n=c_le(a)) return(n);
  519.     reading=1;
  520.     external=1;
  521.     formatted=1;
  522.     lioproc = l_read;
  523.     lquit = 0;
  524.     lcount = 0;
  525.     l_eof = 0;
  526.     if(curunit->uwrt && nowreading(curunit))
  527.         err(a->cierr,errno,"read start");
  528.     l_getc = t_getc;
  529.     l_ungetc = ungetc;
  530.     return(0);
  531. }
  532. c_le(a) cilist *a;
  533. {
  534.     fmtbuf="list io";
  535.     if(a->ciunit>=MXUNIT || a->ciunit<0)
  536.         err(a->cierr,101,"stler");
  537.     scale=recpos=0;
  538.     elist=a;
  539.     curunit = &units[a->ciunit];
  540.     if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
  541.         err(a->cierr,102,"lio");
  542.     cf=curunit->ufd;
  543.     if(!curunit->ufmt) err(a->cierr,103,"lio")
  544.     return(0);
  545. }
  546.